-----------------------------------------------------------------------------
-- |
-- Maintainer  :  Joost Visser
-- Stability   :  experimental
-- Portability :  portable
--
-- Dealing with namespaces.
--
-----------------------------------------------------------------------------

module Language.XMLSchema.NameSpaces where

import Language.XMLSchema.Syntax 
  ( Xs'schema, xs'importSchemaLocation,
    xs'includeSchemaLocation, xs'redefineSchemaLocation)
import Language.XMLSchema.TermInstances
import Language.XMLSchema.XmlInstances

import Text.XML.HaXml.Types -- (Element(..),AttValue(..))
import StrategyLib
import Data.Map as Map
import Debug.Trace 

-----------------------------------------------------------------------------
-- * Schema sets

-- | Type of a set of schemas (belonging to a single project, usually).
type SchemaSet = [Schema]

-- | Schema in various forms: file name, raw XML, parsed.
type Schema = (FilePath, Element, Xs'schema, NameSpaceEnv,FilePath)

-- | Retrieve the relative file name of a given schema.
fileSchema :: Schema -> FilePath
fileSchema (file,_,_,_,_) = file

-- | Retrieve the absolute file name of a given schema.
absoluteFileName :: Schema -> FilePath
absoluteFileName (_,_,_,_,file) = file

-- | Retrieve the raw XML representation of a given schema.
rawSchema :: Schema -> Element
rawSchema (_,element,_,_,_) = element

-- | Retrieve the parsed representation of a given schema.
parsedSchema :: Schema -> Xs'schema
parsedSchema (_,_,schema,_,_) = schema

nseSchema :: Schema -> NameSpaceEnv
nseSchema (_,_,_,nse,_) = nse

-----------------------------------------------------------------------------
-- * Schema locations

-- | Obtain the filenames, relative to a search directory,
--   from the import, include, and redefine constructs of
--   a given schema.
getSchemaLocations :: Schema -> [ChaseName]
getSchemaLocations (infile,_,schema,_,_)
  = Prelude.map fileNameRelToRoot locations
  where
    dir = noBasename infile
    locations = runIdentity $ applyTU (full_tdTU worker) schema
    worker = constTU [] 
              `adhocTU` onImportAttrs
              `adhocTU` onIncludeAttrs
              `adhocTU` onRedefineAttrs
    onImportAttrs attrs 
      = case (xs'importSchemaLocation attrs) of
          Nothing -> return []
          (Just "") -> return []
          (Just l)  -> return [l]
    onIncludeAttrs attrs = return [xs'includeSchemaLocation attrs]
    onRedefineAttrs attrs = return [xs'redefineSchemaLocation attrs]
    fileNameRelToRoot ('h':'t':'t':'p':':':'/':'/':f) = f
    fileNameRelToRoot f = simplifyFileName $ dir++f

-----------------------------------------------------------------------------
-- * Namespace management

-- | The type of universal resource identifiers used in XML namespaces.
type URI = String

-- | The type of prefixes used in XML documents to refer to XML namespaces.
type Prefix = String

-- | Type of XML namespace environments, which may store a default namespace,
--   a target namespace, and a map of prefixes to namespaces.
data NameSpaceEnv  = NameSpaceEnv {
   defaultNameSpace :: Maybe URI
 , targetNameSpace :: Maybe URI
 , prefixMap :: Map Prefix URI
 } deriving (Ord,Show,Eq)

-- | Create an empty name space environment.
emptyNameSpaceEnv :: NameSpaceEnv
emptyNameSpaceEnv = NameSpaceEnv {
   defaultNameSpace = Nothing
 , targetNameSpace = Nothing
 , prefixMap = Map.empty
} 

-- | Retrieve the URI associated to a given prefix from the given
--   namespace environment.
getNS :: NameSpaceEnv -> Prefix -> Maybe URI
getNS env p = Map.lookup p (prefixMap env)

getNS' env p = maybe (trace ("Unknown prefix: "++p++" in "++(show env)) Nothing) Just $ getNS env p

-- | Extract a namespace environment from the XML representation of an XML schema.
--   This function is defined on raw XML rather than the Xs'schema type, because
--   not all necessary information is present in that latter representation.
createNameSpaceEnv :: Element         -- ^ XML element that represent the body of an XML schema. 
                   -> NameSpaceEnv
createNameSpaceEnv (Elem _ attrs _) 
  = foldr update (insertXmlPrefix emptyNameSpaceEnv) attrs
 where
  update ("xmlns",AttValue [Left uri]) nse                          -- xmlns="http://..."
     = nse { defaultNameSpace = Just uri }
  update ('x':'m':'l':'n':'s':':':prefix,AttValue [Left uri]) nse   -- xmlns:foo="http://..."
     = nse { prefixMap = Map.insert prefix uri $ prefixMap nse }
  update ("targetNamespace",AttValue [Left uri]) nse                -- targetNamespace="http://..."
     = nse { targetNameSpace = Just uri }
  update _ nse
     = nse

insertXsPrefix :: NameSpaceEnv -> NameSpaceEnv
insertXsPrefix nse
  = nse { prefixMap = Map.insert "xs" "http://www.w3.org/2001/XMLSchema" (prefixMap nse) }

insertXmlPrefix :: NameSpaceEnv -> NameSpaceEnv
insertXmlPrefix nse
  = nse { prefixMap = Map.insert "xml" "http://www.w3.org/XML/1998/namespace" (prefixMap nse) }

-- | Inverse lookup of prefix that maps to the target namespace.
--   A run-time error is produced when the namespace is mapped to by more than one prefix.
targetPrefix :: NameSpaceEnv -> Maybe Prefix
targetPrefix NameSpaceEnv{ targetNameSpace=Just tns, prefixMap=mp }
  = Map.foldWithKey worker Nothing mp
  where
    worker pfx ns Nothing  = if ns==tns then Just pfx else Nothing
    worker _ ns (Just pfx) = if ns==tns then error "Two prefixes map to target name space!" else (Just pfx)
targetPrefix _ = Nothing

-- | Inverse lookup of prefix that maps to the XML Schema namespace, i.e. "http://www.w3.org/2001/XMLSchema".
--   A run-time error is produced when that namespace is mapped to by more than one prefix.
xmlSchemaPrefix :: NameSpaceEnv -> Maybe Prefix
xmlSchemaPrefix nse@NameSpaceEnv{ prefixMap=mp, defaultNameSpace=dns }
  = Map.foldWithKey worker start mp
  where
    start = if dns==Just tns then Just "" else Nothing
    tns = "http://www.w3.org/2001/XMLSchema"
    worker pfx ns Nothing  = if ns==tns then Just pfx else Nothing
    worker _ ns (Just pfx) = if ns==tns then error msg else (Just pfx)
    msg = "Two prefixes map to XMLSchema name space! "++(show nse)
--xmlSchemaPrefix _ = Nothing

-- | Inverse lookup of prefixes that maps to the XML Schema namespace, 
--   i.e. "http://www.w3.org/2001/XMLSchema".
xmlSchemaPrefixes :: NameSpaceEnv -> [Prefix]
xmlSchemaPrefixes nse@NameSpaceEnv{ prefixMap=mp, defaultNameSpace=dns }
  = Map.foldWithKey worker start mp
  where
    start = if dns==Just tns then [""] else []
    tns = "http://www.w3.org/2001/XMLSchema"
    worker pfx ns pfxs  = if ns==tns then (pfx:pfxs) else pfxs
--xmlSchemaPrefixes _ = []

-----------------------------------------------------------------------------
-- * Helpers that deal with file and directory names.

-- | Removes redundant superdir segments from
--   a file path.
simplifyFileName :: FilePath -> FilePath
simplifyFileName fname = concat $ sepBy "/" $ simplify [] segments
 where
  segments = breakFile fname
  simplify (a:as) ("..":bs) = simplify as bs
  simplify as     (b:bs)    = simplify (b:as) bs
  simplify as     []        = reverse as
  sepBy sep [] = []
  sepBy sep [x] = [x]
  sepBy sep (x:xs) = x:sep:(sepBy sep xs)

-- | Obtain the directory part of a file name.
noBasename :: FilePath -> FilePath
noBasename fname
  =  reverse (dropWhile (/='/') (reverse  fname))

-- | Obtain the file name without extension.
noExtension :: FilePath -> FilePath
noExtension fname
  = reverse (pop $ dropWhile (/='.') (reverse  fname))
    where pop [] = []
          pop (_:xs) = xs

-- | Like 'noExtension' except that it also works on file names
--   that do not have an extension to begin with.
noExtension' :: FilePath -> FilePath
noExtension' fname
 = case reverse (breakFile fname) of
     (seg:segs) 
       | '.' `elem` fname -> segs2fname $ reverse ((noExtension seg):segs)
       | otherwise        -> fname
     _                    -> fname   
   where 
     segs2fname []       = ""
     segs2fname [sg]     = sg
     segs2fname (sg:sgs) = sg++"/"++(segs2fname sgs)

-- | Remove the protocol prefix from a filename.
noProtocol :: FilePath -> FilePath
noProtocol ('h':'t':'t':'p':':':'/':'/':fname) = fname
noProtocol fname = fname

-- | break a file name into its segments, i.e. the pieces between slashes.    
breakFile :: FilePath -> [String]
breakFile = breakWith (=='/')
       
-- | Break path argument into directory names. i.e. the pieces between colons.
breakPath :: String -> [FilePath]
breakPath = breakWith (==':')

-- | Break a list into segments, using a predicate on elements to indicate break points.
--   The break points themselves will be discarded.
breakWith :: (a -> Bool) -> [a] -> [[a]] 
breakWith f x = case break f x of
	(p,(_:pp)) -> p: breakWith f pp
	(p,[]) -> [p]

-----------------------------------------------------------------------------
